home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / setl2 / sun3.lha / setl2-2.2 / etc / setl2.el
Lisp/Scheme  |  1991-01-21  |  60KB  |  1,837 lines
  1. ;
  2. ;  SETL2 Mode
  3. ;  ==========
  4. ;
  5. ;  This file contains a start at a SETL2 major mode for Gnu Emacs.  The
  6. ;  capabilities provided so far fall into three major areas:
  7. ;
  8. ;     1)  A kind of `template' editing, in which you start typing a
  9. ;         keyword, and when the macro can determine what you want to
  10. ;         type, it completes the structure.
  11. ;
  12. ;     2)  The ability to compile within emacs, and step forward or
  13. ;         backward through the error list.
  14. ;
  15. ;     3)  Some help in editing comments.
  16. ;
  17. ;  Please be sure to modify the keyboard map below.  I use a Sparcstation
  18. ;  with a customized version of Emacs to let me remap more of the
  19. ;  keyboard, and the key assignments are convenient for me but unlikely
  20. ;  to work at all for others.  You'll have to modify them to suit your own
  21. ;  keyboard and preferences.
  22. ;
  23. ;
  24. ;  Installation:
  25. ;  -------------
  26. ;
  27. ;  First, modify the keyboard map below.  THIS IS IMPORTANT!  I made no
  28. ;  attempt to pick universally appropriate key assignments, and the ones
  29. ;  below will override some commonly used key assignments!
  30. ;
  31. ;  Second, place the modified file in the path where you keep Emacs
  32. ;  macros, and preferably byte-compile it.
  33. ;
  34. ;  Third, if you wish this mode to be the default for SETL2 files, then
  35. ;  place the following in your .emacs file:
  36. ;
  37. ;     (autoload 'setl2-mode "setl2")
  38. ;     (setq auto-mode-alist (append '(("\\.stl" . setl2-mode)) auto-mode-alist))
  39. ;
  40. ;  That should do it.
  41. ;
  42. ;
  43. ;  Things to be done:
  44. ;  ------------------
  45. ;
  46. ;  There are lots of things I would like to add to this, as time permits.
  47. ;  Here are a few of my ideas.  If there are any Emacs LISP gurus out
  48. ;  there who would like to contribute some of them I'd be grateful.
  49. ;
  50. ;     1)  An execute within emacs similar to compile within emacs.  On an
  51. ;         abort one should be able to step forward and backward through
  52. ;         the call stack.
  53. ;
  54. ;     2)  A tags program for SETL2, as is provided by Gnu for C.
  55. ;
  56. ;     3)  Some improvement in the CASE and IF templates.
  57. ;
  58. ;
  59. ;  Implementation notes:
  60. ;  ---------------------
  61. ;
  62. ;  I must caution the reader of this code that I am neither a fan of nor
  63. ;  an expert in LISP.  I consider it a necessary evil, in order to get
  64. ;  the tremendous benefits from configuring Emacs.  Consequently, my
  65. ;  style is likely to be quite unorthodox.  Generally, I think of
  66. ;  something I'd like to do, then search through the manual until I find
  67. ;  the means to do it.  It may not be the most elegant way, more likely
  68. ;  it is the first way I found.
  69. ;
  70. ;  With that warning, good luck in changing this stuff.  I'm afraid some
  71. ;  customization will be necessary, since several of these functions are
  72. ;  not sufficiently robust.
  73. ;
  74.  
  75. ;
  76. ;  Syntax Table
  77. ;  ------------
  78. ;
  79. ;  I suspect I overuse the punctuation class here, but I don't use syntax
  80. ;  classes myself so I don't know much about them.  If anyone wants to
  81. ;  contribute an improvement, please feel free.
  82. ;
  83.  
  84. (defvar setl2::syntax-table (make-syntax-table)
  85.    "SETL2: Syntax table"
  86. )
  87.  
  88. (modify-syntax-entry ?_   "_"   setl2::syntax-table)
  89. (modify-syntax-entry ?\#  "'"   setl2::syntax-table)
  90. (modify-syntax-entry ?\(  "()"  setl2::syntax-table)
  91. (modify-syntax-entry ?\)  ")("  setl2::syntax-table)
  92. (modify-syntax-entry ?\{  "(}"  setl2::syntax-table)
  93. (modify-syntax-entry ?\}  "){"  setl2::syntax-table)
  94. (modify-syntax-entry ?\[  "(]"  setl2::syntax-table)
  95. (modify-syntax-entry ?\]  ")["  setl2::syntax-table)
  96. (modify-syntax-entry ?*   "."   setl2::syntax-table)
  97. (modify-syntax-entry ?/   "."   setl2::syntax-table)
  98. (modify-syntax-entry ?+   "."   setl2::syntax-table)
  99. (modify-syntax-entry ?-   "."   setl2::syntax-table)
  100. (modify-syntax-entry ?=   "."   setl2::syntax-table)
  101. (modify-syntax-entry ?\|  "."   setl2::syntax-table)
  102. (modify-syntax-entry ?<   "."   setl2::syntax-table)
  103. (modify-syntax-entry ?>   "."   setl2::syntax-table)
  104. (modify-syntax-entry ?:   "."   setl2::syntax-table)
  105. (modify-syntax-entry ?\;  "."   setl2::syntax-table)
  106. (modify-syntax-entry ?\"  "\""  setl2::syntax-table)
  107.  
  108. ;
  109. ;  Keymap
  110. ;  ------
  111. ;
  112. ;  The keymap is almost certain to be inconvenient.  I use a
  113. ;  Sparcstation, with a customized version of Emacs to let me use more of
  114. ;  the function keys.
  115. ;
  116. ;  MODIFY THIS TO SUIT YOUR PREFERENCES!!!
  117. ;
  118.  
  119. (defvar setl2::keymap (make-sparse-keymap)
  120.    "SETL2: Keymap"
  121. )
  122.  
  123. (define-key setl2::keymap "\M-[227z"  'setl2::install-template)   ; F4
  124. (define-key setl2::keymap "\M-\t"     'setl2::next-component)     ; meta-tab
  125. (define-key setl2::keymap "\M-[228z"  'setl2::compile-buffer)     ; F5
  126. (define-key setl2::keymap "\M-[229z"  'setl2::next-error)         ; F6
  127. (define-key setl2::keymap "\M-[230z"  'setl2::previous-error)     ; F7
  128. (define-key setl2::keymap "\M-[224z"  'setl2::pull-comment)       ; F1
  129. (define-key setl2::keymap "\M-[226z"  'setl2::new-comment)        ; F3
  130. (define-key setl2::keymap "\C-k"      'setl2::wrap-in-comment)    ; ^K
  131. (define-key setl2::keymap "\C-s"      'setl2::expose-comment)     ; ^S
  132. (define-key setl2::keymap "\C-v"      'setl2::inline-comment)     ; ^V
  133.  
  134. ;
  135. ;  The following key takes effect only in extracted comment buffers.
  136. ;
  137.  
  138. (defconst setl2::replace-comment-key "\M-[225z"                   ; F2
  139.    "SETL2: return from editing comment"
  140. )
  141.  
  142. ;
  143. ;  This association list maps character strings to functions which open
  144. ;  templates.  It is used by setl2::install-template, to cut the number
  145. ;  of keystrokes we have to map.
  146. ;
  147.  
  148. (defvar setl2::template-alist ()
  149.    "SETL2: map from keyword to template functions"
  150. )
  151.  
  152. (setq setl2::template-alist '(
  153.     ("program"     .  setl2::program-template)
  154.     ("package"     .  setl2::package-template)
  155.     ("class"       .  setl2::class-template)
  156.     ("procedure"   .  setl2::procedure-template)
  157.     ("lambda"      .  setl2::lambda-template)
  158.     ("for"         .  setl2::for-template)
  159.     ("while"       .  setl2::while-template)
  160.     ("until"       .  setl2::until-template)
  161.     ("loop"        .  setl2::loop-template)
  162.     ("if"          .  setl2::if-template)
  163.     ("case"        .  setl2::case-template)
  164. ))
  165.  
  166. ;
  167. ;  Miscellaneous other globals
  168. ;
  169.  
  170. (defconst setl2::comment-prefix "--"
  171.    "SETL2: Comment start symbol"
  172. )
  173.  
  174. ;
  175. ;  setl2-mode
  176. ;  ----------
  177. ;
  178. ;  This function sets the mode of the current buffer to SETL2.
  179. ;
  180.  
  181. (defun setl2-mode ()
  182.    "SETL2: Major mode.  Keymaps are installation-dependent"
  183.  
  184.    (interactive)
  185.  
  186.    (kill-all-local-variables)
  187.    (use-local-map setl2::keymap)
  188.    (setq major-mode 'setl2-mode)
  189.    (setq mode-name "SETL2")
  190.    (set-syntax-table setl2::syntax-table)
  191.    (make-local-variable 'paragraph-start)
  192.    (setq paragraph-start (concat "^$\\|" page-delimiter))
  193.    (make-local-variable 'paragraph-separate)
  194.    (setq paragraph-separate paragraph-start)
  195.    (make-local-variable 'require-final-newline)
  196.    (setq require-final-newline t)
  197.    (run-hooks 'setl2::mode-hook)
  198.    (setq tab-width 3)
  199.    (make-local-variable 'setl2::error-list)
  200.    (setq setl2::error-list '(t ()))
  201.    (make-local-variable 'setl2::next-component-list)
  202.    (setq setl2::next-component-list nil)
  203.  
  204. )
  205.  
  206. ;
  207. ;  Keyword Templates
  208. ;  =================
  209. ;
  210. ;  The basic idea of a template is that from some fairly short
  211. ;  combination of keystrokes, the editor should provide a skeleton of an
  212. ;  appropriate kind of program structure, and step you through filling in
  213. ;  the details.  So for example, ^c-f might produce:
  214. ;
  215. ;     for              loop
  216. ;
  217. ;     end loop;
  218. ;
  219. ;  Then you have to fill in the blanks yourself.  The major modes for
  220. ;  programming languages that I found on prep.ai.mit.edu all prompt you
  221. ;  for the stuff to go in the blanks.  I didn't like that, since I think
  222. ;  whatever you type should go directly in the source buffer, rather than
  223. ;  the minibuffer, and you should be able to take diversions between
  224. ;  these components.  Therefore, the functions here use a `next
  225. ;  component' mechanism instead.  It starts the same way, but returns
  226. ;  control to you as soon as the outline is created.  Then you press a
  227. ;  `next component' key to move to the next blank.
  228. ;
  229. ;  I also provided a somewhat unusual way to get to the original
  230. ;  template.  I have a terrible time remembering all the control
  231. ;  sequences for most template commands, which is probably one reason I
  232. ;  don't use them.  Here, I use the wonderful completion mechanism in
  233. ;  Emacs LISP to get something with longer control sequences, but which
  234. ;  are easier to remember.  Essentially, you fire up the function, and
  235. ;  then start entering characters from the keyword you wish to enter.
  236. ;  After each character, the macro will expand as far as it can.  So the
  237. ;  key for "program" would be "prg", "procedure" would be "prc" and "for"
  238. ;  would be "f".  Experiment a bit, typing slowly, until you get a feel
  239. ;  for the abbreviations.
  240. ;
  241. ;  OK, so what are the quickstart directions?  First, bind the functions
  242. ;  setl2::install-template and setl2::next-component to some keys (see
  243. ;  above).  To start a template, invoke setl2::install-template.  When
  244. ;  you get normal control back, enter whatever component is under the
  245. ;  cursor.  When finished, invoke setl2::next-component to get the next
  246. ;  one.
  247. ;
  248. ;  Before you start reading this stuff, let me give you a crucial
  249. ;  warning:  I don't use this myself, so it may be buggy.  I've never been
  250. ;  a fan of templates, possibly because I'm a fast typist, and I find
  251. ;  that fixing things `smart' macros do wrong is more time consuming than
  252. ;  entering them correctly the first time.  Nevertheless, templates seem
  253. ;  to be a necessary feature, probably for those who can't type quickly
  254. ;  and accurately.  So, here's a stab at it.  If you don't like it, feel
  255. ;  free to provide a superior version.
  256. ;
  257.  
  258. ;
  259. ;  setl2::install-template
  260. ;  -----------------------
  261. ;
  262. ;  This is a function to install any kind of template.  It is generally
  263. ;  used to provide a kind of keyboard mapping from abbreviations to
  264. ;  templates.  We use the template associative list to expand what the
  265. ;  user gives us, until we find a unique keyword.  When we find that, we
  266. ;  call the function to install that specific template.
  267. ;
  268.  
  269. (defun setl2::install-template()
  270.    "SETL2: Install code template, such as for ... loop ... end loop;"
  271.    (interactive)
  272.  
  273.    (let ((setl2::done-flag nil)
  274.          (setl2::abort-flag nil)
  275.          (setl2::prefix-string "")
  276.          setl2::test-string
  277.          setl2::completion
  278.          (setl2::starting-point (point-marker))
  279.          setl2::keyboard-char
  280.          (inhibit-quit t))
  281.  
  282.       (message "Keyword: ")
  283.       (while (not setl2::done-flag)
  284.  
  285.          ;
  286.          ;  Get one character from the keyboard.
  287.          ;
  288.  
  289.          (setq setl2::keyboard-char nil)
  290.          (while (null setl2::keyboard-char)
  291.  
  292.             (sit-for 1)
  293.             (cond
  294.                ((>= unread-command-char 0)
  295.                   (setq setl2::keyboard-char unread-command-char)
  296.                   (setq unread-command-char nil)
  297.                )
  298.                (quit-flag
  299.                   (setq setl2::keyboard-char ?\e)
  300.                )
  301.                ((input-pending-p)
  302.                   (setq setl2::keyboard-char (read-char))
  303.                )
  304.             )
  305.          )
  306.  
  307.          ;
  308.          ;  We've got one character to process.  If it's an escape, we
  309.          ;  quit.  Otherwise, we tack it onto the current prefix string
  310.          ;  and see if it matches something in the template list.
  311.          ;
  312.  
  313.          (if (eq setl2::keyboard-char ?\e)
  314.             (progn
  315.                (setq setl2::done-flag t)
  316.                (setq setl2::abort-flag t)
  317.             )
  318.             (progn
  319.                (setq setl2::keyboard-char
  320.                      (char-to-string setl2::keyboard-char))
  321.                (setq setl2::test-string (concat setl2::prefix-string
  322.                                                 setl2::keyboard-char))
  323.                (setq setl2::completion
  324.                      (try-completion setl2::test-string
  325.                                      setl2::template-alist))
  326.                (cond
  327.                   ((null setl2::completion)
  328.                      (message "Keyword: %s (no match for %s)"
  329.                               setl2::prefix-string
  330.                               setl2::test-string)
  331.                      (ding)
  332.                   )
  333.                   ((eq setl2::completion t)
  334.                      (setq setl2::prefix setl2::test-string)
  335.                      (setq setl2::done-flag t)
  336.                   )
  337.                   (t
  338.                      (if (eq (try-completion setl2::completion
  339.                                              setl2::template-alist) t)
  340.                         (progn
  341.                            (setq setl2::done-flag t)
  342.                            (setq setl2::prefix-string setl2::completion)
  343.                         )
  344.                         (progn
  345.                            (insert (substring setl2::completion
  346.                                               (length setl2::prefix-string)))
  347.                            (setq setl2::prefix-string setl2::completion)
  348.                            (message "Keyword: %s" setl2::prefix-string)
  349.                         )
  350.                      )
  351.                   )
  352.                )
  353.             )
  354.          )
  355.       )
  356.  
  357.       ;
  358.       ;  We have to reset the global quit flag, or emacs will goof up on
  359.       ;  return.
  360.       ;
  361.  
  362.       (setq quit-flag nil)
  363.  
  364.       ;
  365.       ;  We've been inserting stuff directly in the source buffer.  Now
  366.       ;  get rid of it, and let the template function decide what to
  367.       ;  enter.
  368.       ;
  369.  
  370.       (kill-region setl2::starting-point (point))
  371.       (if (not setl2::abort-flag)
  372.          (funcall (cdr (assoc setl2::prefix-string setl2::template-alist)))
  373.       )
  374.    )
  375. )
  376.  
  377. ;
  378. ;  setl2::next-component
  379. ;  ---------------------
  380. ;
  381. ;  This function should jump the user to the next component of the
  382. ;  current template.  The next-component-list consists of either markers
  383. ;  or functions, along with arguments (usually more markers).  We call
  384. ;  all functions, discard null markers, and stop at the first marker
  385. ;  still in the source buffer.
  386. ;
  387.  
  388. (defun setl2::next-component ()
  389.    "SETL2: Move cursor to the next component of the active template"
  390.    (interactive)
  391.  
  392.    (let ((setl2::done-flag nil)
  393.          (setl2::error-flag t)
  394.          (setl2::component))
  395.  
  396.       ;
  397.       ;  We loop until we exhaust the list, or we find an active marker.
  398.       ;
  399.  
  400.       (while (not setl2::done-flag)
  401.  
  402.          (cond
  403.             ((null setl2::next-component-list)
  404.                (setq setl2::done-flag t)
  405.                (if setl2::error-flag
  406.                   (progn
  407.                      (message "No pending program structures!")
  408.                      (ding)
  409.                   )
  410.                )
  411.             )
  412.             ((listp (car setl2::next-component-list))
  413.                (setq setl2::component (car setl2::next-component-list))
  414.                (setq setl2::next-component-list
  415.                      (cdr setl2::next-component-list))
  416.                (funcall (car setl2::component)
  417.                         (cdr setl2::component))
  418.                (setq setl2::error-flag nil)
  419.             )
  420.             ((markerp (car setl2::next-component-list))
  421.                (if (null (marker-position (car setl2::next-component-list)))
  422.                   (setq setl2::next-component-list
  423.                         (cdr setl2::next-component-list))
  424.                   (progn
  425.                      (goto-char (marker-position
  426.                                    (car setl2::next-component-list)))
  427.                      (setq setl2::next-component-list
  428.                            (cdr setl2::next-component-list))
  429.                      (setq setl2::error-flag nil)
  430.                      (setq setl2::done-flag t)
  431.                   )
  432.                )
  433.             )
  434.             (t
  435.                (setq setl2::next-component-list
  436.                      (cdr setl2::next-component-list))
  437.             )
  438.          )
  439.       )
  440.    )
  441. )
  442.  
  443. ;
  444. ;  Template Macros
  445. ;  ===============
  446. ;
  447. ;  The following macros insert the actual templates into the source
  448. ;  buffer.  The previous stuff was control functions, which just call
  449. ;  these.
  450. ;
  451.  
  452. ;
  453. ;  setl2::program-template
  454. ;  -----------------------
  455. ;
  456. ;  The program, package, class, and procedure templates all have some
  457. ;  logic to plant the unit name in the tail, so the user never has to
  458. ;  type `end <program name>;'.  Here we open up a program and plant the
  459. ;  procedure to fill in the tail.
  460. ;
  461.  
  462. (defun setl2::program-template ()
  463.    "SETL2: Template => program ... ; ... end <name>;"
  464.    (interactive)
  465.  
  466.    (let ((setl2::starting-point (point))
  467.          (setl2::structure-column (current-column))
  468.          (setl2::marker-list ()))
  469.  
  470.       (setq setl2::marker-list
  471.             (cons (point-marker) setl2::marker-list))
  472.       (insert "program ")
  473.       (setq setl2::marker-list
  474.             (cons (point-marker) setl2::marker-list))
  475.       (insert ";\n\n\n\n\n")
  476.       (previous-line 3)
  477.       (setq setl2::marker-list
  478.             (cons (point-marker) setl2::marker-list))
  479.       (next-line 2)
  480.       (setl2::move-to-column setl2::structure-column)
  481.       (insert "end")
  482.       (setq setl2::marker-list
  483.             (cons (point-marker) setl2::marker-list))
  484.       (insert ";")
  485.       (setq setl2::next-component-list
  486.             (append
  487.                (list
  488.                   (list 'setl2::insert-unit-tail
  489.                         "program[ \\t]*\\([^ \\t;]+\\)[ \\t]*;"
  490.                         1
  491.                         (nth 3 setl2::marker-list)
  492.                         (nth 0 setl2::marker-list))
  493.                   (list 'setl2::column-marker
  494.                         (nth 1 setl2::marker-list)
  495.                         (+ setl2::structure-column tab-width)))
  496.                setl2::next-component-list))
  497.       (goto-char (marker-position (nth 2 setl2::marker-list)))
  498.    )
  499. )
  500.  
  501. ;
  502. ;  setl2::package-template
  503. ;  -----------------------
  504. ;
  505. ;  The program, package, class, and procedure templates all have some
  506. ;  logic to plant the unit name in the tail, so the user never has to
  507. ;  type `end <package name>;'.  Here we open up a package and plant the
  508. ;  procedure to fill in the tail.
  509. ;
  510.  
  511. (defun setl2::package-template ()
  512.    "SETL2: Template => package ... ; ... end <name>;"
  513.    (interactive)
  514.  
  515.    (let ((setl2::starting-point (point))
  516.          (setl2::structure-column (current-column))
  517.          (setl2::marker-list ()))
  518.  
  519.       (setq setl2::marker-list
  520.             (cons (point-marker) setl2::marker-list))
  521.       (insert "package ")
  522.       (setq setl2::marker-list
  523.             (cons (point-marker) setl2::marker-list))
  524.       (insert ";\n\n\n\n\n")
  525.       (previous-line 3)
  526.       (setq setl2::marker-list
  527.             (cons (point-marker) setl2::marker-list))
  528.       (next-line 2)
  529.       (setl2::move-to-column setl2::structure-column)
  530.       (insert "end")
  531.       (setq setl2::marker-list
  532.             (cons (point-marker) setl2::marker-list))
  533.       (insert ";")
  534.       (setq setl2::next-component-list
  535.             (append
  536.                (list
  537.                   (list 'setl2::insert-unit-tail
  538.                    "package[ \\t]*\\(body[ \\t]*\\)?\\([^ \\t;]+\\)[ \\t]*;"
  539.                         2
  540.                         (nth 3 setl2::marker-list)
  541.                         (nth 0 setl2::marker-list))
  542.                   (list 'setl2::column-marker
  543.                         (nth 1 setl2::marker-list)
  544.                         (+ setl2::structure-column tab-width)))
  545.                setl2::next-component-list))
  546.       (goto-char (marker-position (nth 2 setl2::marker-list)))
  547.    )
  548. )
  549.  
  550. ;
  551. ;  setl2::class-template
  552. ;  ---------------------
  553. ;
  554. ;  The program, package, class, and procedure templates all have some
  555. ;  logic to plant the unit name in the tail, so the user never has to
  556. ;  type `end <class name>;'.  Here we open up a class and plant the
  557. ;  procedure to fill in the tail.
  558. ;
  559.  
  560. (defun setl2::class-template ()
  561.    "SETL2: Template => class ... ; ... end <name>;"
  562.    (interactive)
  563.  
  564.    (let ((setl2::starting-point (point))
  565.          (setl2::structure-column (current-column))
  566.          (setl2::marker-list ()))
  567.  
  568.       (setq setl2::marker-list
  569.             (cons (point-marker) setl2::marker-list))
  570.       (insert "class ")
  571.       (setq setl2::marker-list
  572.             (cons (point-marker) setl2::marker-list))
  573.       (insert ";\n\n\n\n\n")
  574.       (previous-line 3)
  575.       (setq setl2::marker-list
  576.             (cons (point-marker) setl2::marker-list))
  577.       (next-line 2)
  578.       (setl2::move-to-column setl2::structure-column)
  579.       (insert "end")
  580.       (setq setl2::marker-list
  581.             (cons (point-marker) setl2::marker-list))
  582.       (insert ";")
  583.       (setq setl2::next-component-list
  584.             (append
  585.                (list
  586.                   (list 'setl2::insert-unit-tail
  587.                    "class[ \\t]*\\(body[ \\t]*\\)?\\([^ \\t;]+\\)[ \\t]*;"
  588.                         2
  589.                         (nth 3 setl2::marker-list)
  590.                         (nth 0 setl2::marker-list))
  591.                   (list 'setl2::column-marker
  592.                         (nth 1 setl2::marker-list)
  593.                         (+ setl2::structure-column tab-width)))
  594.                setl2::next-component-list))
  595.       (goto-char (marker-position (nth 2 setl2::marker-list)))
  596.    )
  597. )
  598.  
  599. ;
  600. ;  setl2::procedure-template
  601. ;  -------------------------
  602. ;
  603. ;  The program, package, class, and procedure templates all have some
  604. ;  logic to plant the unit name in the tail, so the user never has to
  605. ;  type `end <procedure name>;'.  Here we open up a procedure and plant the
  606. ;  procedure to fill in the tail.
  607. ;
  608.  
  609. (defun setl2::procedure-template ()
  610.    "SETL2: Template => procedure ... (...) ; ... end <name>;"
  611.    (interactive)
  612.  
  613.    (let ((setl2::starting-point (point))
  614.          (setl2::structure-column (current-column))
  615.          (setl2::marker-list ()))
  616.  
  617.       (setq setl2::marker-list
  618.             (cons (point-marker) setl2::marker-list))
  619.       (insert "procedure ")
  620.       (setq setl2::marker-list
  621.             (cons (point-marker) setl2::marker-list))
  622.       (insert ";\n\n\n\n\n")
  623.       (previous-line 3)
  624.       (setq setl2::marker-list
  625.             (cons (point-marker) setl2::marker-list))
  626.       (next-line 2)
  627.       (setl2::move-to-column setl2::structure-column)
  628.       (insert "end")
  629.       (setq setl2::marker-list
  630.             (cons (point-marker) setl2::marker-list))
  631.       (insert ";")
  632.       (setq setl2::next-component-list
  633.             (append
  634.                (list
  635.                   (list 'setl2::insert-unit-tail
  636.                         "procedure[ \\t]*\\([^ \\t(;]+\\)[^;]*;"
  637.                         1
  638.                         (nth 3 setl2::marker-list)
  639.                         (nth 0 setl2::marker-list))
  640.                   (list 'setl2::column-marker
  641.                         (nth 1 setl2::marker-list)
  642.                         (+ setl2::structure-column tab-width)))
  643.                setl2::next-component-list))
  644.       (goto-char (marker-position (nth 2 setl2::marker-list)))
  645.    )
  646. )
  647.  
  648. ;
  649. ;  setl2::insert-unit-tail
  650. ;  ------------------------
  651. ;
  652. ;  This function fills in the unit name from the header, assuming the
  653. ;  programmer didn't move anything.
  654. ;
  655.  
  656. (defun setl2::insert-unit-tail (args)
  657.    "SETL2: Ending name for program, package, ..."
  658.  
  659.    (let ((setl2::starting-point (point))
  660.          (setl2::head-pattern (nth 0 args))
  661.          (setl2::match-number (nth 1 args))
  662.          (setl2::unit-head (nth 2 args))
  663.          (setl2::unit-tail (nth 3 args)))
  664.  
  665.       (if (not (null (marker-position setl2::unit-head)))
  666.          (progn
  667.             (goto-char (marker-position setl2::unit-head))
  668.             (if (and (looking-at setl2::head-pattern)
  669.                      (not (null (marker-position setl2::unit-tail))))
  670.                (progn
  671.                   (goto-char (marker-position setl2::unit-tail))
  672.                   (insert " ")
  673.                   (insert (buffer-substring
  674.                              (match-beginning setl2::match-number)
  675.                              (match-end setl2::match-number)))
  676.                )
  677.             )
  678.          )
  679.       )
  680.       (goto-char setl2::starting-point)
  681.    )
  682. )
  683.  
  684. ;
  685. ;  setl2::lambda-template
  686. ;  ----------------------
  687. ;
  688. ;  The lambda template is easier than the other procedure-like templates.
  689. ;  We don't have to worry about a name.
  690. ;
  691.  
  692. (defun setl2::lambda-template ()
  693.    "SETL2: Template => lambda; ... end lambda;"
  694.    (interactive)
  695.  
  696.    (let ((setl2::starting-point (point))
  697.          (setl2::structure-column (current-column))
  698.          (setl2::marker-list ()))
  699.  
  700.       (insert "lambda")
  701.       (setq setl2::marker-list
  702.             (cons (point-marker) setl2::marker-list))
  703.       (insert ";\n\n\n\n\n")
  704.       (previous-line 3)
  705.       (setq setl2::marker-list
  706.             (cons (point-marker) setl2::marker-list))
  707.       (next-line 2)
  708.       (setl2::move-to-column setl2::structure-column)
  709.       (insert "end lambda;")
  710.       (setq setl2::next-component-list
  711.             (append
  712.                (list
  713.                   (list 'setl2::column-marker
  714.                         (car setl2::marker-list)
  715.                         (+ setl2::structure-column tab-width)))
  716.                setl2::next-component-list))
  717.       (goto-char (marker-position (nth 1 setl2::marker-list)))
  718.  
  719.    )
  720. )
  721.  
  722. ;
  723. ;  setl2::for-template
  724. ;  -------------------
  725. ;
  726. ;  The loop templates are all relatively straightforward.  We only need
  727. ;  to plant a marker for the body.
  728. ;
  729.  
  730. (defun setl2::for-template ()
  731.    "SETL2: Template => for ... loop ... end loop;"
  732.    (interactive)
  733.  
  734.    (let ((setl2::starting-point (point))
  735.          (setl2::structure-column (current-column))
  736.          (setl2::marker-list ()))
  737.  
  738.       (insert "for ")
  739.       (setq setl2::marker-list
  740.             (cons (point-marker) setl2::marker-list))
  741.       (insert " loop\n\n\n\n\n")
  742.       (previous-line 3)
  743.       (setq setl2::marker-list
  744.             (cons (point-marker) setl2::marker-list))
  745.       (next-line 2)
  746.       (setl2::move-to-column setl2::structure-column)
  747.       (insert "end loop;")
  748.       (setq setl2::next-component-list
  749.             (append
  750.                (list
  751.                   (list 'setl2::column-marker
  752.                         (car setl2::marker-list)
  753.                         (+ setl2::structure-column tab-width)))
  754.                setl2::next-component-list))
  755.       (goto-char (marker-position (nth 1 setl2::marker-list)))
  756.  
  757.    )
  758. )
  759.  
  760. ;
  761. ;  setl2::while-template
  762. ;  ---------------------
  763. ;
  764. ;  The loop templates are all relatively straightforward.  We only need
  765. ;  to plant a marker for the body.
  766. ;
  767.  
  768. (defun setl2::while-template ()
  769.    "SETL2: Template => while ... loop ... end loop;"
  770.    (interactive)
  771.  
  772.    (let ((setl2::starting-point (point))
  773.          (setl2::structure-column (current-column))
  774.          (setl2::marker-list ()))
  775.  
  776.       (insert "while ")
  777.       (setq setl2::marker-list
  778.             (cons (point-marker) setl2::marker-list))
  779.       (insert " loop\n\n\n\n\n")
  780.       (previous-line 3)
  781.       (setq setl2::marker-list
  782.             (cons (point-marker) setl2::marker-list))
  783.       (next-line 2)
  784.       (setl2::move-to-column setl2::structure-column)
  785.       (insert "end loop;")
  786.       (setq setl2::next-component-list
  787.             (append
  788.                (list
  789.                   (list 'setl2::column-marker
  790.                         (car setl2::marker-list)
  791.                         (+ setl2::structure-column tab-width)))
  792.                setl2::next-component-list))
  793.       (goto-char (marker-position (nth 1 setl2::marker-list)))
  794.  
  795.    )
  796. )
  797.  
  798. ;
  799. ;  setl2::until-template
  800. ;  ---------------------
  801. ;
  802. ;  The loop templates are all relatively straightforward.  We only need
  803. ;  to plant a marker for the body.
  804. ;
  805.  
  806. (defun setl2::until-template ()
  807.    "SETL2: Template => until ... loop ... end loop;"
  808.    (interactive)
  809.  
  810.    (let ((setl2::starting-point (point))
  811.          (setl2::structure-column (current-column))
  812.          (setl2::marker-list ()))
  813.  
  814.       (insert "until ")
  815.       (setq setl2::marker-list
  816.             (cons (point-marker) setl2::marker-list))
  817.       (insert " loop\n\n\n\n\n")
  818.       (previous-line 3)
  819.       (setq setl2::marker-list
  820.             (cons (point-marker) setl2::marker-list))
  821.       (next-line 2)
  822.       (setl2::move-to-column setl2::structure-column)
  823.       (insert "end loop;")
  824.       (setq setl2::next-component-list
  825.             (append
  826.                (list
  827.                   (list 'setl2::column-marker
  828.                         (car setl2::marker-list)
  829.                         (+ setl2::structure-column tab-width)))
  830.                setl2::next-component-list))
  831.       (goto-char (marker-position (nth 1 setl2::marker-list)))
  832.  
  833.    )
  834. )
  835.  
  836. ;
  837. ;  setl2::loop-template
  838. ;  --------------------
  839. ;
  840. ;  The loop templates are all relatively straightforward.  We only need
  841. ;  to plant a marker for the body.
  842. ;
  843.  
  844. (defun setl2::loop-template ()
  845.    "SETL2: Template => loop ... end loop;"
  846.    (interactive)
  847.  
  848.    (let ((setl2::starting-point (point))
  849.          (setl2::structure-column (current-column))
  850.          (setl2::marker-list ()))
  851.  
  852.       (insert "loop\n\n\n\n\n")
  853.       (previous-line 3)
  854.       (setq setl2::marker-list
  855.             (cons (point-marker) setl2::marker-list))
  856.       (next-line 2)
  857.       (setl2::move-to-column setl2::structure-column)
  858.       (insert "end loop;")
  859.       (goto-char (marker-position (car setl2::marker-list)))
  860.       (setl2::move-to-column (+ setl2::structure-column tab-width))
  861.  
  862.    )
  863. )
  864.  
  865. ;
  866. ;  setl2::if-template
  867. ;  ------------------
  868. ;
  869. ;  I have a severe problem with the if and case templates.  The problem
  870. ;  is that both have a variable number of clauses, elseif for if
  871. ;  statements and when for case.  I could use separate templates, but
  872. ;  that seems like too much to invoke them.  So, for now, I'm just going
  873. ;  to give a bunch of the clauses, on the assumption that deleting a
  874. ;  block of text is painless but adding clauses is not.
  875. ;
  876.  
  877. (defun setl2::if-template ()
  878.    "SETL2: Template => if .. then .. else .. end if;"
  879.    (interactive)
  880.  
  881.    (let ((setl2::starting-point (point))
  882.          (setl2::structure-column (current-column))
  883.          (setl2::marker-list ()))
  884.  
  885.       (insert "if ")
  886.       (setq setl2::marker-list
  887.             (cons (point-marker) setl2::marker-list))
  888.       (insert " then\n\n\n\n\n\n\n\n\n\n\n\n")
  889.       (previous-line 10)
  890.       (setq setl2::marker-list
  891.             (cons (point-marker) setl2::marker-list))
  892.       (next-line 2)
  893.       (setl2::move-to-column setl2::structure-column)
  894.       (insert "elseif ")
  895.       (setq setl2::marker-list
  896.             (cons (point-marker) setl2::marker-list))
  897.       (insert " then")
  898.       (next-line 2)
  899.       (beginning-of-line)
  900.       (setq setl2::marker-list
  901.             (cons (point-marker) setl2::marker-list))
  902.       (next-line 2)
  903.       (setl2::move-to-column setl2::structure-column)
  904.       (insert "else")
  905.       (next-line 2)
  906.       (beginning-of-line)
  907.       (setq setl2::marker-list
  908.             (cons (point-marker) setl2::marker-list))
  909.       (next-line 2)
  910.       (setl2::move-to-column setl2::structure-column)
  911.       (insert "end if;")
  912.  
  913.       (setq setl2::next-component-list
  914.             (append
  915.                (list
  916.                   (list 'setl2::column-marker
  917.                         (nth 3 setl2::marker-list)
  918.                         (+ setl2::structure-column tab-width))
  919.                   (nth 2 setl2::marker-list)
  920.                   (list 'setl2::column-marker
  921.                         (nth 1 setl2::marker-list)
  922.                         (+ setl2::structure-column tab-width))
  923.                   (list 'setl2::column-marker
  924.                         (nth 0 setl2::marker-list)
  925.                         (+ setl2::structure-column tab-width)))
  926.                setl2::next-component-list))
  927.  
  928.       (goto-char (marker-position (nth 4 setl2::marker-list)))
  929.  
  930.    )
  931. )
  932.  
  933. ;
  934. ;  setl2::case-template
  935. ;  --------------------
  936. ;
  937. ;  I have a severe problem with the if and case templates.  The problem
  938. ;  is that both have a variable number of clauses, elseif for if
  939. ;  statements and when for case.  I could use separate templates, but
  940. ;  that seems like too much to invoke them.  So, for now, I'm just going
  941. ;  to give a bunch of the clauses, on the assumption that deleting a
  942. ;  block of text is painless but adding clauses is not.
  943. ;
  944.  
  945. (defun setl2::case-template ()
  946.    "SETL2: Template => case ... end case;"
  947.    (interactive)
  948.  
  949.    (let ((setl2::starting-point (point))
  950.          (setl2::structure-column (current-column))
  951.          (setl2::marker-list ()))
  952.  
  953.       (insert "case ")
  954.       (setq setl2::marker-list
  955.             (cons (point-marker) setl2::marker-list))
  956.       (insert "\n\n\n\n\n\n\n\n\n\n\n\n\n\n")
  957.       (previous-line 12)
  958.       (setl2::move-to-column (+ setl2::structure-column tab-width))
  959.       (insert "when ")
  960.       (setq setl2::marker-list
  961.             (cons (point-marker) setl2::marker-list))
  962.       (insert " =>")
  963.       (next-line 2)
  964.       (beginning-of-line)
  965.       (setq setl2::marker-list
  966.             (cons (point-marker) setl2::marker-list))
  967.       (next-line 2)
  968.       (setl2::move-to-column (+ setl2::structure-column tab-width))
  969.       (insert "when ")
  970.       (setq setl2::marker-list
  971.             (cons (point-marker) setl2::marker-list))
  972.       (insert " =>")
  973.       (next-line 2)
  974.       (beginning-of-line)
  975.       (setq setl2::marker-list
  976.             (cons (point-marker) setl2::marker-list))
  977.       (next-line 2)
  978.       (setl2::move-to-column (+ setl2::structure-column tab-width))
  979.       (insert "otherwise =>")
  980.       (next-line 2)
  981.       (beginning-of-line)
  982.       (setq setl2::marker-list
  983.             (cons (point-marker) setl2::marker-list))
  984.       (next-line 2)
  985.       (setl2::move-to-column setl2::structure-column)
  986.       (insert "end case;")
  987.  
  988.       (setq setl2::next-component-list
  989.             (append
  990.                (list
  991.                   (nth 4 setl2::marker-list)
  992.                   (list 'setl2::column-marker
  993.                         (nth 3 setl2::marker-list)
  994.                         (+ setl2::structure-column (* tab-width 2)))
  995.                   (nth 2 setl2::marker-list)
  996.                   (list 'setl2::column-marker
  997.                         (nth 1 setl2::marker-list)
  998.                         (+ setl2::structure-column (* tab-width 2)))
  999.                   (list 'setl2::column-marker
  1000.                         (nth 0 setl2::marker-list)
  1001.                         (+ setl2::structure-column (* tab-width 2))))
  1002.                setl2::next-component-list))
  1003.  
  1004.       (goto-char (marker-position (nth 5 setl2::marker-list)))
  1005.  
  1006.    )
  1007. )
  1008.  
  1009. ;
  1010. ;  setl2::column-marker
  1011. ;  --------------------
  1012. ;
  1013. ;  I don't trust markers appearing after the last non-blank column.  It's
  1014. ;  too easy to remove them.  Therefore, in situations where I'd like to
  1015. ;  plant such a column, I plant one at the beginning of a line instead
  1016. ;  and keep my desired column number.  A marker at the beginning of a
  1017. ;  line is much more likely to be kept.
  1018. ;
  1019.  
  1020. (defun setl2::column-marker (args)
  1021.    (let ((setl2::line-marker (nth 0 args))
  1022.          (setl2::column-number (nth 1 args)))
  1023.  
  1024.       (if (not (null (marker-position setl2::line-marker)))
  1025.          (progn
  1026.             (goto-char (marker-position setl2::line-marker))
  1027.             (move-to-column setl2::column-number)
  1028.             (if (< (current-column) setl2::column-number)
  1029.                (insert (make-string
  1030.                           (- setl2::column-number (current-column))
  1031.                           (string-to-char " ")))
  1032.             )
  1033.             (setq setl2::next-component-list
  1034.                   (cons (point-marker) setl2::next-component-list))
  1035.          )
  1036.       )
  1037.    )
  1038. )
  1039.  
  1040. ;
  1041. ;  setl2::move-to-column
  1042. ;  ---------------------
  1043. ;
  1044. ;  This function moves the cursor to a given column, inserting spaces if
  1045. ;  necessary.  The result is that the cursor REALLY moves to the desired
  1046. ;  column, whether or not something was there previously.
  1047. ;
  1048.  
  1049. (defun setl2::move-to-column (setl2::column)
  1050.  
  1051.    (move-to-column setl2::column)
  1052.    (if (and (not buffer-read-only)
  1053.             (< (current-column) setl2::column))
  1054.       (insert (make-string (- setl2::column (current-column))
  1055.                            (string-to-char " ")))
  1056.    )
  1057. )
  1058.  
  1059. ;
  1060. ;  Compile functions
  1061. ;  =================
  1062. ;
  1063. ;  One of the more useful features of a programming language major mode
  1064. ;  is the ability to compile the current buffer, and step forward and
  1065. ;  back through the error messages.  This is most useful on short
  1066. ;  projects, consisting of a single source file (it tends to break down
  1067. ;  when one needs makefiles).
  1068. ;
  1069.  
  1070. ;
  1071. ;  setl2::compile_buffer
  1072. ;  ---------------------
  1073. ;
  1074. ;  This function compiles the current buffer.  It first saves the buffer,
  1075. ;  if necessary, executes the SETL2 compiler and gathers up the error
  1076. ;  messages in the list.  The following two functions allow the user to
  1077. ;  step forward and backward through that list.
  1078. ;
  1079.  
  1080. (defun setl2::compile-buffer ()
  1081.    (interactive)
  1082.  
  1083.    (let ((setl2::source-name buffer-file-name)
  1084.          (setl2::source-buffer (current-buffer))
  1085.          (setl2::listing-buffer (generate-new-buffer "*errors*"))
  1086.          setl2::error-line
  1087.          setl2::error-column
  1088.          setl2::error-text)
  1089.  
  1090.       ;
  1091.       ;  Save the setl2 file if necessary.
  1092.       ;
  1093.  
  1094.       (save-buffer)
  1095.  
  1096.       ;
  1097.       ;  Compile the current buffer
  1098.       ;
  1099.  
  1100.       (setq setl2::error-list ())
  1101.       (switch-to-buffer setl2::listing-buffer)
  1102.       (shell-command (concat "stlc -n " setl2::source-name) t)
  1103.  
  1104.       ;
  1105.       ;  Read through the errors, gathering them into a list
  1106.       ;
  1107.  
  1108.       (beginning-of-buffer)
  1109.       (while (re-search-forward "\\[\\([0-9]*\\):\\([0-9]*\\)\\]" nil t)
  1110.  
  1111.          (setq setl2::error-line
  1112.                (string-to-int (buffer-substring
  1113.                                (match-beginning 1) (match-end 1))))
  1114.          (setq setl2::error-column
  1115.                (string-to-int (buffer-substring
  1116.                               (match-beginning 2) (match-end 2))))
  1117.          (re-search-forward "\\([^ ].*\\)$" nil t)
  1118.          (setq setl2::error-text (buffer-substring
  1119.                                  (match-beginning 1) (match-end 1)))
  1120.  
  1121.          (switch-to-buffer setl2::source-buffer)
  1122.          (goto-line setl2::error-line)
  1123.          (setl2::move-to-column (- setl2::error-column 1))
  1124.          (setq setl2::error-list (cons (list (point-marker) setl2::error-text)
  1125.                                  setl2::error-list))
  1126.  
  1127.          (switch-to-buffer setl2::listing-buffer)
  1128.  
  1129.       )
  1130.  
  1131.       (switch-to-buffer setl2::source-buffer)
  1132.       (setq setl2::error-list (cons t (reverse (cons nil setl2::error-list))))
  1133.       (kill-buffer setl2::listing-buffer)
  1134.  
  1135.       (if (null (nth 1 setl2::error-list))
  1136.          (message "Compilation Successful")
  1137.          (setl2::next-error)
  1138.       )
  1139.    )
  1140. )
  1141.  
  1142. ;
  1143. ;  setl2::next-error
  1144. ;  -----------------
  1145. ;
  1146. ;  This function finds the next remaining error in the error list and
  1147. ;  displays it.  It assumes that the original error list consists of a
  1148. ;  direction flag, a list of errors, and a nil to indicate the end of the
  1149. ;  list.
  1150. ;
  1151.  
  1152. (defun setl2::next-error ()
  1153.    (interactive)
  1154.  
  1155.    (let ((setl2::last-was-forward (car setl2::error-list))
  1156.          setl2::displayed-error)
  1157.  
  1158.       ;
  1159.       ;  Strip off the direction flag and switch directions, if
  1160.       ;  necessary.
  1161.       ;
  1162.  
  1163.       (if setl2::last-was-forward
  1164.          (setq setl2::error-list (cdr setl2::error-list))
  1165.          (setq setl2::error-list
  1166.                (reverse (cons (nth 1 setl2::error-list)
  1167.                               (reverse (nthcdr 2 setl2::error-list)))))
  1168.       )
  1169.  
  1170.       ;
  1171.       ;  Strip away any error messages whose position has been deleted
  1172.       ;
  1173.  
  1174.       (while (and (not (null (car setl2::error-list)))
  1175.                   (null (marker-position (car (car setl2::error-list)))))
  1176.          (setq setl2::error-list (cdr setl2::error-list))
  1177.       )
  1178.  
  1179.       ;
  1180.       ;  We either have a valid error to display, or there are no new
  1181.       ;  ones.
  1182.       ;
  1183.  
  1184.       (if (null (car setl2::error-list))
  1185.          (progn
  1186.             (message "No more errors")
  1187.             (setq setl2::error-list (cons t setl2::error-list))
  1188.          )
  1189.          (progn
  1190.             (setq setl2::displayed-error (car setl2::error-list))
  1191.             (setq setl2::error-list
  1192.                (cons t (reverse (cons setl2::displayed-error
  1193.                                       (reverse (cdr setl2::error-list))))))
  1194.             (goto-char (marker-position (car setl2::displayed-error)))
  1195.             (message (car (cdr setl2::displayed-error)))
  1196.          )
  1197.       )
  1198.    )
  1199. )
  1200.  
  1201. ;
  1202. ;  setl2::previous-error
  1203. ;  ---------------------
  1204. ;
  1205. ;  This function finds the previous remaining error in the error list and
  1206. ;  displays it.  It assumes that the original error list consists of a
  1207. ;  direction flag, a list of errors, and a nil to indicate the end of the
  1208. ;  list.
  1209. ;
  1210.  
  1211. (defun setl2::previous-error ()
  1212.    (interactive)
  1213.  
  1214.    (let ((setl2::last-was-forward (car setl2::error-list))
  1215.          setl2::displayed-error)
  1216.  
  1217.       ;
  1218.       ;  Strip off the direction flag and switch directions, if
  1219.       ;  necessary.
  1220.       ;
  1221.  
  1222.       (if setl2::last-was-forward
  1223.          (setq setl2::error-list
  1224.                (reverse (cons (car (reverse setl2::error-list))
  1225.                               (reverse
  1226.                                  (cdr (reverse (cdr setl2::error-list)))))))
  1227.          (setq setl2::error-list (reverse (cdr setl2::error-list)))
  1228.       )
  1229.  
  1230.       ;
  1231.       ;  Strip away any error messages whose position has been deleted
  1232.       ;
  1233.  
  1234.       (while (and (not (null (car setl2::error-list)))
  1235.                   (null (marker-position (car (car setl2::error-list)))))
  1236.          (setq setl2::error-list (cdr setl2::error-list))
  1237.       )
  1238.  
  1239.       ;
  1240.       ;  We either have a valid error to display, or there are no new
  1241.       ;  ones.
  1242.       ;
  1243.  
  1244.       (if (null (car setl2::error-list))
  1245.          (progn
  1246.             (message "No more errors")
  1247.             (setq setl2::error-list (cons nil (reverse setl2::error-list)))
  1248.          )
  1249.          (progn
  1250.             (setq setl2::displayed-error (car setl2::error-list))
  1251.             (setq setl2::error-list
  1252.                (cons nil (cons setl2::displayed-error
  1253.                                (reverse (cdr setl2::error-list)))))
  1254.             (goto-char (marker-position (car setl2::displayed-error)))
  1255.             (message (car (cdr setl2::displayed-error)))
  1256.          )
  1257.       )
  1258.    )
  1259. )
  1260.  
  1261. ;
  1262. ;  Comments
  1263. ;  ========
  1264. ;
  1265. ;  Like every programmer, I have a preferred comment style.  This section
  1266. ;  facilitates editing comments in that style.  If you're using this
  1267. ;  package, but have a different comment style, you'll probably want to
  1268. ;  delete this section completely and write your own comment support
  1269. ;  functions.
  1270. ;
  1271. ;  My style is to use block comments at the beginning of procedures or
  1272. ;  sections within a procedure.  I use relatively few in-line comments.
  1273. ;  To be honest, the comments I use are meant to provide large markers
  1274. ;  around procedures as much as to convey useful information.  Lots of
  1275. ;  times the drivel I put there could have been inferred just as easily
  1276. ;  from the procedure name.
  1277. ;
  1278. ;  I like to use word processing mode to edit the comment text.  The
  1279. ;  following procedures are designed to pick the text out of the
  1280. ;  surrounding boilerplate and to replace the text within new
  1281. ;  boilerplate.  The boilerplate is usually just a bunch of lines with --
  1282. ;  in the same column.  There are two optional things which can appear as
  1283. ;  well, though.  First, I sometimes format comments as TeX source (I
  1284. ;  have other macros which 'texify' files, and copy such comments
  1285. ;  intact).  These begin with --\.  There may also be a form feed on the
  1286. ;  first line.  All of this stuff is ignored when pulling a comment, but
  1287. ;  restored when the text is replaced.
  1288. ;
  1289.  
  1290. ;
  1291. ;  setl2::pull-comment
  1292. ;  -------------------
  1293. ;
  1294. ;  This is the entry point for grabbing the text out of a comment.  We
  1295. ;  make sure there is an appropriate comment, then call
  1296. ;  setl2::pull-comment-here to do the actual grabbing.  This saves a lot
  1297. ;  of duplication of code with setl2::new-comment.
  1298. ;
  1299.  
  1300. (defun setl2::pull-comment ()
  1301.    (interactive)
  1302.    (if (null (search-forward setl2::comment-prefix nil t))
  1303.       (message "No comment found")
  1304.       (progn
  1305.          (backward-char (length setl2::comment-prefix))
  1306.          (setl2::pull-comment-here)
  1307.       )
  1308.    )
  1309. )
  1310.  
  1311. ;
  1312. ;  setl2::new-comment
  1313. ;  ------------------
  1314. ;
  1315. ;  This is the entry point for making a new comment, in word processing
  1316. ;  style.  We just insert the comment and call setl2::pull-comment-here.
  1317. ;
  1318.  
  1319. (defun setl2::new-comment ()
  1320.    (interactive)
  1321.    (insert setl2::comment-prefix)
  1322.    (backward-char (length setl2::comment-prefix))
  1323.    (setl2::pull-comment-here)
  1324. )
  1325.  
  1326. ;
  1327. ;  setl2::pull-comment-here
  1328. ;  ------------------------
  1329. ;
  1330. ;  This is the guts of the comment-pulling procedure.  There are a lot of
  1331. ;  things to do here, so just follow the step-by-step comments.
  1332. ;
  1333.  
  1334. (defun setl2::pull-comment-here ()
  1335.    (let ((setl2::main-buffer (current-buffer))
  1336.          (setl2::comment-position (point-marker))
  1337.          (setl2::comment-column (current-column))
  1338.          (setl2::TeX-flag nil)
  1339.          (setl2::form-feed-flag nil)
  1340.          setl2::comment-line
  1341.          (setl2::comment-block ())
  1342.          setl2::comment-line-begin
  1343.          (setl2::blank-columns 99999))
  1344.  
  1345.       ;
  1346.       ;  First, we collect the lines of the comment into a (reversed)
  1347.       ;  list.  We pay attention to suffixes "\\" and "\f", and keep
  1348.       ;  track of the minimum number of blanks after the prefix, as well.
  1349.       ;
  1350.  
  1351.       (while (and (equal (current-column) setl2::comment-column)
  1352.                   (looking-at (regexp-quote setl2::comment-prefix)))
  1353.  
  1354.          (forward-char (length setl2::comment-prefix))
  1355.          (setq setl2::comment-line "")
  1356.  
  1357.          (if (looking-at "\\\\")
  1358.             (progn
  1359.                (setq setl2::TeX-flag t)
  1360.                (forward-char 1)
  1361.                (setq setl2::comment-line (concat setl2::comment-line " "))
  1362.             )
  1363.          )
  1364.  
  1365.          (if (looking-at "\f")
  1366.             (progn
  1367.                (setq setl2::form-feed-flag t)
  1368.                (forward-char 1)
  1369.                (setq setl2::comment-line (concat setl2::comment-line ""))
  1370.             )
  1371.          )
  1372.  
  1373.          (if (looking-at "[ \t]*$")
  1374.             (setq setl2::comment-line "")
  1375.             (progn
  1376.                (setq setl2::comment-line-begin (point))
  1377.                (end-of-line)
  1378.                (untabify setl2::comment-line-begin (point))
  1379.                (setq setl2::comment-line
  1380.                      (concat setl2::comment-line
  1381.                              (buffer-substring setl2::comment-line-begin
  1382.                                                (point))))
  1383.                (setq setl2::blank-columns
  1384.                      (min setl2::blank-columns
  1385.                           (string-match "[^ ]" setl2::comment-line)))
  1386.             )
  1387.          )
  1388.          (setq setl2::comment-block (cons setl2::comment-line
  1389.                                           setl2::comment-block))
  1390.          (next-line 1)
  1391.          (move-to-column setl2::comment-column)
  1392.       )
  1393.  
  1394.       ;
  1395.       ;  Now setl2::comment-block has the text of the comment as a list
  1396.       ;  of lines.  We have to create a word-processing buffer for it.
  1397.       ;
  1398.  
  1399.       (switch-to-buffer (generate-new-buffer "*comment*"))
  1400.  
  1401.       (beginning-of-buffer)
  1402.       (while (not (null setl2::comment-block))
  1403.          (setq setl2::comment-line (car setl2::comment-block))
  1404.          (if (equal (length setl2::comment-line) 0)
  1405.             (insert "\n")
  1406.             (progn
  1407.                (insert setl2::comment-line)
  1408.                (insert "\n")
  1409.                (beginning-of-buffer)
  1410.                (move-to-column setl2::blank-columns)
  1411.                (kill-region (point-min) (point))
  1412.             )
  1413.          )
  1414.          (setq setl2::comment-block (cdr setl2::comment-block))
  1415.          (beginning-of-buffer)
  1416.       )
  1417.  
  1418.       ;
  1419.       ;  We've inserted the lines into the buffer, so we're ready to do
  1420.       ;  some beautification.  We remove trailing spaces and leading
  1421.       ;  blank lines.
  1422.       ;
  1423.  
  1424.       (beginning-of-buffer)
  1425.       (replace-regexp " +$" "")
  1426.       (beginning-of-buffer)
  1427.       (while (and (< (point) (point-max))
  1428.                   (looking-at "$"))
  1429.          (delete-char 1)
  1430.       )
  1431.  
  1432.       ;
  1433.       ;  We have to save some stuff in buffer-local variables, for use by
  1434.       ;  the comment replacement function.
  1435.       ;
  1436.  
  1437.       (make-local-variable 'setl2::save-main-buffer)
  1438.       (setq setl2::save-main-buffer setl2::main-buffer)
  1439.       (make-local-variable 'setl2::save-comment-position)
  1440.       (setq setl2::save-comment-position setl2::comment-position)
  1441.       (make-local-variable 'setl2::save-TeX-flag)
  1442.       (setq setl2::save-TeX-flag setl2::TeX-flag)
  1443.       (make-local-variable 'setl2::save-form-feed-flag)
  1444.       (setq setl2::save-form-feed-flag setl2::form-feed-flag)
  1445.  
  1446.       ;
  1447.       ;  Now we establish word processing mode.  The real work here is
  1448.       ;  done by Emacs' auto-fill mode, all we do is call it, and set up
  1449.       ;  a key to return us to the source buffer.
  1450.       ;
  1451.  
  1452.       (auto-fill-mode 1)
  1453.       (setq fill-column (- 70 setl2::comment-column))
  1454.       (make-local-variable 'setl2::comment-keymap)
  1455.       (if (not (null (current-local-map)))
  1456.  
  1457.          (setq setl2::comment-keymap (copy-keymap (current-local-map)))
  1458.          (progn
  1459.             (setq setl2::comment-keymap (make-sparse-keymap))
  1460.             (use-local-map setl2::comment-keymap)
  1461.          )
  1462.       )
  1463.       (local-set-key setl2::replace-comment-key 'setl2::replace-comment)
  1464.    )
  1465. )
  1466.  
  1467. ;
  1468. ;  setl2::replace-comment
  1469. ;  ----------------------
  1470. ;
  1471. ;  This function replaces text extracted from a comment.  Like the
  1472. ;  comment-pulling procedure, there are a lot of things to do here, so
  1473. ;  follow the step-by-step comments.
  1474. ;
  1475.  
  1476. (defun setl2::replace-comment ()
  1477.    (interactive)
  1478.  
  1479.    (let ((setl2::comment-buffer (current-buffer))
  1480.          (setl2::main-buffer setl2::save-main-buffer)
  1481.          (setl2::comment-position setl2::save-comment-position)
  1482.          (setl2::TeX-flag setl2::save-TeX-flag)
  1483.          (setl2::form-feed-flag setl2::save-form-feed-flag)
  1484.          setl2::comment-line
  1485.          setl2::comment-column
  1486.          (setl2::comment-block ())
  1487.          setl2::comment-line-begin
  1488.          setl2::done-flag
  1489.          setl2::save-position
  1490.          setl2::block-flag)
  1491.  
  1492.       ;
  1493.       ;  First we do some buffer conditioning.  We remove tabs, trailing
  1494.       ;  spaces, and leading and trailing blank lines.
  1495.       ;
  1496.  
  1497.       (untabify (point-min) (point-max))
  1498.  
  1499.       (beginning-of-buffer)
  1500.       (replace-regexp " +$" "")
  1501.  
  1502.       (beginning-of-buffer)
  1503.       (while (and (< (point) (point-max))
  1504.                   (looking-at "$"))
  1505.          (delete-char 1)
  1506.       )
  1507.  
  1508.       (end-of-buffer)
  1509.       (insert "\n\n\n\n")
  1510.       (if (re-search-backward "[^ \t\n]" nil t)
  1511.          (kill-region (+ (point) 1) (point-max))
  1512.          (kill-region (point-min) (point-max))
  1513.       )
  1514.  
  1515.       (end-of-buffer)
  1516.       (insert "\n")
  1517.       (previous-line 1)
  1518.  
  1519.       ;
  1520.       ;  Now we gather up the lines into a list.  This is an ugly loop,
  1521.       ;  since LISP doesn't let me break out of a while loop (at least
  1522.       ;  in my meager knowledge of LISP!).
  1523.       ;
  1524.  
  1525.       (beginning-of-line)
  1526.       (setq setl2::done-flag nil)
  1527.       (while (not setl2::done-flag)
  1528.          (setq setl2::comment-line-begin (point))
  1529.          (end-of-line)
  1530.          (if (equal (point) setl2::comment-line-begin)
  1531.             (setq setl2::comment-block (cons "" setl2::comment-block))
  1532.             (setq setl2::comment-block
  1533.                   (cons (buffer-substring setl2::comment-line-begin (point))
  1534.                         setl2::comment-block))
  1535.          )
  1536.          (beginning-of-line)
  1537.          (if (equal (point) (point-min))
  1538.             (setq setl2::done-flag t)
  1539.             (previous-line 1)
  1540.          )
  1541.       )
  1542.  
  1543.       ;
  1544.       ;  We've got our comment text gathered up again, so we switch back
  1545.       ;  to the source buffer.  We've got to look out for the user
  1546.       ;  deleting either the source buffer or the marker, but fortunately
  1547.       ;  the marker-position function handles both cases.
  1548.       ;
  1549.  
  1550.       (if (null (marker-position setl2::comment-position))
  1551.          (message "Comment's original position has disappeared!")
  1552.  
  1553.          ;
  1554.          ;  The original position is still there, so go to it.
  1555.          ;
  1556.  
  1557.          (progn
  1558.  
  1559.             (switch-to-buffer setl2::main-buffer)
  1560.             (goto-char setl2::comment-position)
  1561.  
  1562.             ;
  1563.             ;  Clear out the old comment text.
  1564.             ;
  1565.  
  1566.             (setq setl2::comment-column (current-column))
  1567.             (while (and (equal (current-column) setl2::comment-column)
  1568.                         (looking-at (regexp-quote setl2::comment-prefix)))
  1569.  
  1570.                (forward-char (length setl2::comment-prefix))
  1571.                (if (not (looking-at "[ \t]*$"))
  1572.                   (kill-line)
  1573.                )
  1574.                (next-line 1)
  1575.                (move-to-column setl2::comment-column)
  1576.  
  1577.             )
  1578.  
  1579.             ;
  1580.             ;  Insert new text, as long as we still have the old comment
  1581.             ;  prefixes.
  1582.             ;
  1583.  
  1584.             (goto-char setl2::comment-position)
  1585.             (forward-char (length setl2::comment-prefix))
  1586.             (if setl2::TeX-flag
  1587.                (insert "\\")
  1588.             )
  1589.             (if setl2::form-feed-flag
  1590.                (insert "\f")
  1591.             )
  1592.             (goto-char setl2::comment-position)
  1593.             (next-line 1)
  1594.             (move-to-column setl2::comment-column)
  1595.  
  1596.             (while (and (equal (current-column) setl2::comment-column)
  1597.                         (looking-at (regexp-quote setl2::comment-prefix))
  1598.                         (not (null setl2::comment-block)))
  1599.  
  1600.                (forward-char (length setl2::comment-prefix))
  1601.                (if setl2::TeX-flag
  1602.                   (insert "\\")
  1603.                )
  1604.                (insert "  ")
  1605.                (insert (car setl2::comment-block))
  1606.                (setq setl2::comment-block (cdr setl2::comment-block))
  1607.                (next-line 1)
  1608.                (move-to-column setl2::comment-column)
  1609.             )
  1610.  
  1611.             ;
  1612.             ;  We ran out of comment text, or old prefixes.
  1613.             ;
  1614.  
  1615.             (if (not (null setl2::comment-block))
  1616.  
  1617.                ;
  1618.                ;  The prefixes gave out first.  We insert new lines,
  1619.                ;  lining up with the old prefixes.
  1620.                ;
  1621.  
  1622.                (progn
  1623.                   (previous-line 1)
  1624.                   (while (not (null setl2::comment-block))
  1625.                      (end-of-line)
  1626.                      (insert "\n")
  1627.                      (insert (make-string setl2::comment-column
  1628.                                           (string-to-char " ")))
  1629.                      (insert setl2::comment-prefix)
  1630.                      (if setl2::TeX-flag
  1631.                         (insert "\\")
  1632.                      )
  1633.                      (insert "  ")
  1634.                      (insert (car setl2::comment-block))
  1635.                      (setq setl2::comment-block (cdr setl2::comment-block))
  1636.                   )
  1637.                   (end-of-line)
  1638.                   (insert "\n")
  1639.                   (insert (make-string setl2::comment-column
  1640.                                        (string-to-char " ")))
  1641.                   (insert setl2::comment-prefix)
  1642.                   (if setl2::TeX-flag
  1643.                      (insert "\\")
  1644.                   )
  1645.                )
  1646.  
  1647.                ;
  1648.                ;  We ran out of comment text, but have some prefixes
  1649.                ;  left.
  1650.                ;
  1651.  
  1652.                (progn
  1653.                   (forward-char (length setl2::comment-prefix))
  1654.                   (if setl2::TeX-flag
  1655.                      (insert "\\")
  1656.                   )
  1657.                   (next-line 1)
  1658.  
  1659.                   ;
  1660.                   ;  Check whether any of the remaining prefixes have
  1661.                   ;  text in front of them.  If they do, we leave the
  1662.                   ;  lines there but remove the prefixes.  Otherwise we
  1663.                   ;  delete the lines altogether.
  1664.                   ;
  1665.  
  1666.                   (move-to-column setl2::comment-column)
  1667.                   (setq setl2::save-position (point))
  1668.                   (setq setl2::block-flag t)
  1669.                   (while (and (equal (current-column) setl2::comment-column)
  1670.                               (looking-at
  1671.                                  (regexp-quote setl2::comment-prefix))
  1672.                               setl2::block-flag)
  1673.                      (beginning-of-line)
  1674.                      (if (looking-at (concat "[ \t]*" setl2::comment-prefix))
  1675.                         (setq setl2::block-flag nil)
  1676.                      )
  1677.                   )
  1678.                   (goto-char setl2::save-position)
  1679.                   (while (and (equal (current-column) setl2::comment-column)
  1680.                               (looking-at
  1681.                                  (regexp-quote setl2::comment-prefix)))
  1682.                      (if setl2::block-flag
  1683.                         (progn
  1684.                            (beginning-of-line)
  1685.                            (kill-line 1)
  1686.                            (move-to-column setl2::comment-column)
  1687.                         )
  1688.                         (progn
  1689.                            (kill-line)
  1690.                            (next-line 1)
  1691.                            (move-to-column setl2::comment-column)
  1692.                         )
  1693.                      )
  1694.                   )
  1695.                )
  1696.             )
  1697.  
  1698.             ;
  1699.             ;  We're done with the comment buffer.
  1700.             ;
  1701.  
  1702.             (kill-buffer setl2::comment-buffer)
  1703.             (goto-char setl2::comment-position)
  1704.  
  1705.          )
  1706.       )
  1707.    )
  1708. )
  1709.  
  1710. ;
  1711. ;  setl2::wrap-in-comment
  1712. ;  ----------------------
  1713. ;
  1714. ;  One of the nice things about some versions of C is that one can easily
  1715. ;  comment out a large chunk of a program by placing the beginning and
  1716. ;  ending delimiter.  This causes as many difficulties as benefits,
  1717. ;  though, since some compilers won't nest comments, and those which do
  1718. ;  get very confused when one forgets an ending delimiter.  It seems more
  1719. ;  socially acceptable therefore to use prefix comments, which start with
  1720. ;  some marker and extend to the end of a line.  SETL2 follows this
  1721. ;  convention.
  1722. ;
  1723. ;  A little help from an editor macro can give one the ability to comment
  1724. ;  out a large block of a SETL2 program, just as we can with C.  This
  1725. ;  function just inserts the comment symbol on all lines between point
  1726. ;  and mark, inclusive.  The companion function `setl2::expose-comment'
  1727. ;  removes these comment symbols and reactivates the enclosed code.
  1728. ;
  1729.  
  1730. (defun setl2::wrap-in-comment ()
  1731.    (interactive)
  1732.  
  1733.    (let (setl2::start-position setl2::first-line setl2::count)
  1734.  
  1735.       (setq setl2::start-position (point-marker))
  1736.  
  1737.       (if (< (point) (mark))
  1738.          (progn
  1739.             (setq setl2::first-line (point))
  1740.             (setq setl2::count (count-lines (point) (mark)))
  1741.          )
  1742.          (progn
  1743.             (setq setl2::first-line (mark))
  1744.             (setq setl2::count (count-lines (mark) (point)))
  1745.          )
  1746.       )
  1747.  
  1748.       (goto-char setl2::first-line)
  1749.       (beginning-of-line)
  1750.       (while (>= setl2::count 0)
  1751.  
  1752.          (insert setl2::comment-prefix)
  1753.          (next-line 1)
  1754.          (beginning-of-line)
  1755.          (setq setl2::count (- setl2::count 1))
  1756.  
  1757.       )
  1758.  
  1759.       (goto-char (marker-position setl2::start-position))
  1760.  
  1761.    )
  1762. )
  1763.  
  1764. ;
  1765. ;  setl2::expose-comment
  1766. ;  ----------------------
  1767. ;
  1768. ;  This is the companion to `setl2::wrap-in-comment'.  It exposes the
  1769. ;  text previously hidden.
  1770. ;
  1771.  
  1772. (defun setl2::expose-comment ()
  1773.    (interactive)
  1774.  
  1775.    (let (setl2::start-position setl2::first-line setl2::last-line)
  1776.  
  1777.       (setq setl2::start-position (point-marker))
  1778.  
  1779.       (if (< (point) (mark))
  1780.          (progn
  1781.             (setq setl2::first-line (point))
  1782.             (setq setl2::count (count-lines (point) (mark)))
  1783.          )
  1784.          (progn
  1785.             (setq setl2::first-line (mark))
  1786.             (setq setl2::count (count-lines (mark) (point)))
  1787.          )
  1788.       )
  1789.  
  1790.       (goto-char setl2::first-line)
  1791.       (beginning-of-line)
  1792.       (while (>= setl2::count 0)
  1793.  
  1794.          (if (looking-at (regexp-quote setl2::comment-prefix))
  1795.             (delete-char (length setl2::comment-prefix))
  1796.          )
  1797.          (next-line 1)
  1798.          (beginning-of-line)
  1799.          (setq setl2::count (- setl2::count 1))
  1800.  
  1801.       )
  1802.  
  1803.       (if (not (null (marker-position setl2::start-position)))
  1804.          (goto-char (marker-position setl2::start-position))
  1805.       )
  1806.  
  1807.    )
  1808. )
  1809.  
  1810. ;
  1811. ;  setl2::inline-comment
  1812. ;  ---------------------
  1813. ;
  1814. ;  I rarely use in-line comments, except for one situation -- to explain
  1815. ;  the meaning of a variable.  In that case I use something like this:
  1816. ;
  1817. ;     var x;                              -- never use x
  1818. ;
  1819. ;  I always start these things in column 40.  This macro just makes it
  1820. ;  easy to get out there.
  1821. ;
  1822.  
  1823. (defun setl2::inline-comment ()
  1824.    (interactive)
  1825.  
  1826.    (end-of-line)
  1827.    (if (> (current-column) 40)
  1828.       (insert "\n")
  1829.    )
  1830.  
  1831.    (insert (make-string (- 40 (current-column))
  1832.                         (string-to-char " ")))
  1833.    (insert setl2::comment-prefix)
  1834.    (insert " ")
  1835.  
  1836. )
  1837.